home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gnu / adainc / i-cporte.adb < prev    next >
Text File  |  1996-01-30  |  9KB  |  298 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --                I N T E R F A C E S . C . P O S I X _ R T E               --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.4 $                             --
  10. --                                                                          --
  11. --       Copyright (c) 1991,1992,1993,1994, FSU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNARL is free software; you can redistribute it  and/or modify it  under --
  14. -- terms  of  the  GNU  Library General Public License  as published by the --
  15. -- Free Software  Foundation;  either version 2, or (at  your  option)  any --
  16. -- later  version.  GNARL is distributed  in the hope that  it will be use- --
  17. -- ful, but but WITHOUT ANY WARRANTY;  without even the implied warranty of --
  18. -- MERCHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. -- eral Library Public License  for more details.  You should have received --
  20. -- a  copy of the GNU Library General Public License along with GNARL;  see --
  21. -- file COPYING.LIB.  If not,  write to the  Free Software Foundation,  675 --
  22. -- Mass Ave, Cambridge, MA 02139, USA.                                      --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Interfaces.C.POSIX_Error; use Interfaces.C.Posix_Error;
  27. --  Used for, POSIX_Error,
  28. --            Return_Code
  29.  
  30. with Unchecked_Conversion;
  31.  
  32. package body Interfaces.C.POSIX_RTE is
  33.  
  34.    function Address_to_Pointer is new
  35.      Unchecked_Conversion (System.Address, sigaction_ptr);
  36.  
  37.    function Address_to_Pointer is new
  38.      Unchecked_Conversion (System.Address, sigset_t_ptr);
  39.  
  40.    function Address_to_Pointer is new
  41.      Unchecked_Conversion (System.Address, jmp_buf_ptr);
  42.  
  43.    function Address_to_Pointer is new
  44.      Unchecked_Conversion (System.Address, sigjmp_buf_ptr);
  45.  
  46.    --  The following are P1003.5 interfaces.  I am not sure that this is a
  47.    --  good idea, but these can't be exactly the same as the C functions
  48.    --  in any case.
  49.  
  50.    procedure Signal_Add (Set : in out Signal_Set; Sig : in Signal) is
  51.       function sigaddset (Set : sigset_t_ptr; Sig : Signal) return Return_Code;
  52.       pragma Import (C, sigaddset, "sigaddset");
  53.  
  54.    begin
  55.       if sigaddset (Address_to_Pointer (Set'Address), Sig) /= 0 then
  56.          raise POSIX_Error.POSIX_Error;
  57.       end if;
  58.    end Signal_Add;
  59.  
  60.    procedure Signal_Delete (Set : in out Signal_Set; Sig : in Signal) is
  61.       function sigdelset (Set : sigset_t_ptr; Sig : Signal) return Return_Code;
  62.       pragma Import (C, sigdelset, "sigdelset");
  63.  
  64.    begin
  65.       if sigdelset (Address_to_Pointer (Set'Address), Sig) /= 0 then
  66.          raise POSIX_Error.POSIX_Error;
  67.       end if;
  68.    end Signal_Delete;
  69.  
  70.    procedure Signal_Add_All (Set : in out Signal_Set) is
  71.       function sigfillset (Set : sigset_t_ptr) return Return_Code;
  72.       pragma Import (C, sigfillset, "sigfillset");
  73.  
  74.    begin
  75.       if sigfillset (Address_to_Pointer (Set'Address)) /= 0 then
  76.          raise POSIX_Error.POSIX_Error;
  77.       end if;
  78.    end Signal_Add_All;
  79.  
  80.    procedure Signal_Delete_All (Set : in out Signal_Set) is
  81.       function sigemptyset (Set : sigset_t_ptr) return Return_Code;
  82.       pragma Import (C, sigemptyset, "sigemptyset");
  83.  
  84.    begin
  85.       if sigemptyset (Address_to_Pointer (Set'Address)) /= 0 then
  86.          raise POSIX_Error.POSIX_Error;
  87.       end if;
  88.    end Signal_Delete_All;
  89.  
  90.    function Member_Of (Set : Signal_Set; Sig : Signal) return Boolean is
  91.       function sigismember
  92.         (Set  : sigset_t_ptr;
  93.          Sig  : Signal)
  94.          return Return_Code;
  95.       pragma Import (C, sigismember, "sigismember");
  96.  
  97.    begin
  98.       if sigismember (Address_to_Pointer (Set'Address), Sig) = 1 then
  99.          return True;
  100.       else
  101.          return False;
  102.       end if;
  103.    end Member_Of;
  104.  
  105.    ---------------
  106.    -- sigaction --
  107.    ---------------
  108.  
  109.    procedure sigaction
  110.      (sig    : Signal;
  111.       act    : struct_sigaction;
  112.       oact   : out struct_sigaction;
  113.       Result : out POSIX_Error.Return_Code)
  114.    is
  115.       function sigaction_base
  116.         (sig  : Signal;
  117.          act  : sigaction_ptr;
  118.          oact : sigaction_ptr) return POSIX_Error.Return_Code;
  119.       pragma Import (C, sigaction_base, "sigaction");
  120.  
  121.    begin
  122.       Result := sigaction_base (sig, Address_to_Pointer (act'Address),
  123.             Address_to_Pointer (oact'Address));
  124.    end sigaction;
  125.  
  126.    ---------------
  127.    -- sigaction --
  128.    ---------------
  129.  
  130.    procedure sigaction
  131.      (sig    : Signal;
  132.       act    : sigaction_ptr;
  133.       oact   : out struct_sigaction;
  134.       Result : out Return_Code) is
  135.  
  136.       function sigaction_base
  137.         (sig  : Signal;
  138.          act  : sigaction_ptr;
  139.          oact : sigaction_ptr) return Return_Code;
  140.       pragma Import (C, sigaction_base, "sigaction");
  141.  
  142.    begin
  143.       Result := sigaction_base
  144.         (Signal (sig), act, Address_to_Pointer (oact'Address));
  145.    end sigaction;
  146.  
  147.    -----------------
  148.    -- sigprocmask --
  149.    -----------------
  150.  
  151.    --  Install new signal mask and obtain old one
  152.  
  153.    procedure sigprocmask
  154.      (how    : int;
  155.       set    : Signal_Set;
  156.       oset   : out Signal_Set;
  157.       Result : out POSIX_Error.Return_Code)
  158.    is
  159.       function sigprocmask_base
  160.         (how  : int;
  161.          set  : sigset_t_ptr;
  162.          oset : sigset_t_ptr)
  163.          return POSIX_Error.Return_Code;
  164.       pragma Import (C, sigprocmask_base, "sigprocmask");
  165.  
  166.    begin
  167.       Result := sigprocmask_base (how, Address_to_Pointer (set'Address),
  168.             Address_to_Pointer (oset'Address));
  169.    end sigprocmask;
  170.  
  171.    -----------------
  172.    -- sigprocmask --
  173.    -----------------
  174.  
  175.    --  Install new signal mask and obtain old one
  176.  
  177.    procedure sigprocmask
  178.      (how    : int;
  179.       set    : sigset_t_ptr;
  180.       oset   : out Signal_Set;
  181.       Result : out POSIX_Error.Return_Code)
  182.    is
  183.       function sigprocmask_base
  184.         (how  : int;
  185.          set  : sigset_t_ptr;
  186.          oset : sigset_t_ptr)
  187.          return POSIX_Error.Return_Code;
  188.       pragma Import (C, sigprocmask_base, "sigprocmask");
  189.  
  190.    begin
  191.       Result :=
  192.          sigprocmask_base (how, set, Address_to_Pointer (oset'Address));
  193.    end sigprocmask;
  194.  
  195.    ----------------
  196.    -- sigsuspend --
  197.    ----------------
  198.  
  199.    --  Suspend waiting for signals in mask and resume after
  200.    --  executing handler or take default action
  201.  
  202.    procedure sigsuspend
  203.      (mask : Signal_Set;
  204.       Result : out POSIX_Error.Return_Code) is
  205.  
  206.       function sigsuspend_base
  207.         (mask : sigset_t_ptr)
  208.          return POSIX_Error.Return_Code;
  209.       pragma Import (C, sigsuspend_base, "sigsuspend");
  210.  
  211.    begin
  212.       Result := sigsuspend_base (Address_to_Pointer (mask'Address));
  213.    end sigsuspend;
  214.  
  215.    ----------------
  216.    -- sigpending --
  217.    ----------------
  218.  
  219.    --  Get pending signals on thread and process
  220.  
  221.    procedure sigpending
  222.      (set    : out Signal_Set;
  223.       Result : out POSIX_Error.Return_Code)
  224.    is
  225.       function sigpending_base
  226.         (set  : sigset_t_ptr)
  227.          return POSIX_Error.Return_Code;
  228.       pragma Import (C, sigpending_base, "sigpending");
  229.  
  230.    begin
  231.       Result := sigpending_base (Address_to_Pointer (set'Address));
  232.    end sigpending;
  233.  
  234.    -------------
  235.    -- longjmp --
  236.    -------------
  237.  
  238.    --  Execute a jump across procedures according to setjmp
  239.  
  240.    procedure longjmp (env : jmp_buf; val : int) is
  241.       procedure longjmp_base (env : jmp_buf_ptr; val : int);
  242.       pragma Import (C, longjmp_base, "longjmp");
  243.  
  244.    begin
  245.       longjmp_base (Address_to_Pointer (env'Address), val);
  246.    end longjmp;
  247.  
  248.    ----------------
  249.    -- siglongjmp --
  250.    ----------------
  251.  
  252.    --  Execute a jump across procedures according to sigsetjmp
  253.  
  254.    procedure siglongjmp (env : sigjmp_buf; val : int) is
  255.       procedure siglongjmp_base (env : sigjmp_buf_ptr; val : int);
  256.       pragma Import (C, siglongjmp_base, "siglongjmp");
  257.  
  258.    begin
  259.       siglongjmp_base (Address_to_Pointer (env'Address), val);
  260.    end siglongjmp;
  261.  
  262.    ------------
  263.    -- setjmp --
  264.    ------------
  265.  
  266.    --  Set up a jump across procedures and return here with longjmp
  267.  
  268.    procedure setjmp (env : jmp_buf; Result : out Return_Code) is
  269.       function setjmp_base (env : jmp_buf_ptr) return Return_Code;
  270.       pragma Import (C, setjmp_base, "setjmp");
  271.  
  272.    begin
  273.       Result := setjmp_base (Address_to_Pointer (env'Address));
  274.    end setjmp;
  275.  
  276.    ---------------
  277.    -- sigsetjmp --
  278.    ---------------
  279.  
  280.    --  Set up a jump across procedures and return here with siglongjmp
  281.  
  282.    procedure sigsetjmp
  283.      (env      : sigjmp_buf;
  284.       savemask : int;
  285.       Result   : out Return_Code)
  286.    is
  287.       function sigsetjmp_base
  288.         (env      : sigjmp_buf_ptr;
  289.          savemask : int)
  290.          return     Return_Code;
  291.       pragma Import (C, sigsetjmp_base, "sigsetjmp");
  292.  
  293.    begin
  294.       Result := sigsetjmp_base (Address_to_Pointer (env'Address), savemask);
  295.    end sigsetjmp;
  296.  
  297. end Interfaces.C.POSIX_RTE;
  298.